home *** CD-ROM | disk | FTP | other *** search
/ Macwelt 1 / Macwelt DVD 1.toast / Web-Publishing / HTML-Editoren / Alpha ƒ / Tcl / SystemCode / CorePackages / completions.tcl < prev    next >
Encoding:
Text File  |  2001-01-15  |  18.3 KB  |  627 lines
  1. ## -*-Tcl-*-
  2.  # ###################################################################
  3.  #  AlphaTcl - core Tcl engine
  4.  # 
  5.  #  FILE: "completions.tcl"
  6.  #                                    created: 27/7/97 {12:43:41 am} 
  7.  #                                last update: 01/15/2001 {10:53:16 AM} 
  8.  #  Author: Vince Darley
  9.  #  E-mail: <vince@santafe.edu>
  10.  #    mail: 317 Paseo de Peralta
  11.  #          Santa Fe, NM 87501, USA
  12.  #     www: <http://www.santafe.edu/~vince/>
  13.  #  
  14.  # Copyright (c) 1997-2000  Vince Darley, all rights reserved
  15.  # 
  16.  # Basic parts of the completion package -- to handle word and
  17.  # file completion, but allowing very simple piggy-backing of
  18.  # advanced completions.
  19.  # ###################################################################
  20.  ##
  21.  
  22.  
  23. namespace eval bind {}
  24. namespace eval completion {}
  25.  
  26. # setup two globals
  27. ensureset completion::in_progress_proc error
  28. ensureset completion::in_progress_pos -1.0
  29.  
  30. ## 
  31.  # -------------------------------------------------------------------------
  32.  #     
  33.  #    "bind::Completion"    --
  34.  #    
  35.  #  If we're already completing, jump to that procedure, else go
  36.  #  through a mode-dependent list of completion procedures given by
  37.  #  the array 'completions', these return either '1' to indicate
  38.  #  termination, or '0' to say either that they failed or that they
  39.  #  succeeded and that further completion procedures may be applied.
  40.  #     
  41.  #  If no mode-dependent procedure list exists (as in a basic Alpha
  42.  #  installation), then just the 'user' completions and 'word'
  43.  #  completions are attempted.
  44.  #     
  45.  #  The list of procedures to try is copied into 'completion::chain',
  46.  #  so completion procs can modify that list if they like. 
  47.  # -------------------------------------------------------------------------
  48.  ##
  49. proc bind::Completion {} {
  50.     if {![completion::tabDeleteSelection]} return
  51.     
  52.     global completion::in_progress_proc
  53.     if {[completion::notAlready]} {
  54.     set completion::in_progress_proc error
  55.     if {[completion::user]} return
  56.     set m [modeALike]
  57.     global completions mode completion::chain
  58.     if {[info exists completions($mode)]} {
  59.         set completion::chain $completions($mode)
  60.         while 1 {
  61.         if {[set c [lindex ${completion::chain} 0]] == ""} {
  62.             break
  63.         }
  64.         set completion::chain [lreplace ${completion::chain} 0 0]
  65.         if {[completion $m $c]} return
  66.         }
  67.         message "No further completions exist, perhaps you should write your own."
  68.     } else {
  69.         completion::word actual
  70.     }
  71.     }
  72. }
  73.  
  74. proc completion::user {{cmd ""}} { 
  75.     return 0 
  76. }
  77.  
  78. proc completion::getChoices {type choices} {
  79.     switch -- $type {
  80.     "-command" {
  81.         return [uplevel 1 $choices]
  82.     }
  83.     "-list" {
  84.         return $choices
  85.     }
  86.     "-variable" {
  87.         global [lindex [split $choices "\("] 0]
  88.         return [set $choices]
  89.     }
  90.     default {
  91.         error "Bad option '$type' to completion::getChoices"
  92.     }
  93.     }
  94. }
  95.  
  96. proc completion::fromChoices {type choices prefix} {
  97.     switch -- $type {
  98.     "-command" {
  99.         set matches {}
  100.         foreach w [uplevel 1 $choices] {
  101.         if {[string match "[quote::Find $prefix]*" $w]} {
  102.             lappend matches $w
  103.         }
  104.         }
  105.         return $matches
  106.     }
  107.     "-list" {
  108.         set matches {}
  109.         foreach w $choices {
  110.         if {[string match "[quote::Find $prefix]*" $w]} {
  111.             lappend matches $w
  112.         }
  113.         }
  114.         return $matches
  115.     }
  116.     "-variable" {
  117.         return [completion::fromList $prefix $choices]
  118.     }
  119.     default {
  120.         error "Bad option '$type' to completion::fromChoices"
  121.     }
  122.     }
  123. }
  124.  
  125. ## 
  126.  # -------------------------------------------------------------------------
  127.  #     
  128.  #    "completion::fromList" --
  129.  #    
  130.  #  Given a 'cmd' prefix and the name of a list to search, that list
  131.  #  being stored in alphabetical order and starting/ending with
  132.  #  whitespace, this proc returns a list of all matches with 'cmd', or
  133.  #  "" if there were none.  Updated so works with arrays too (Nov'96)
  134.  #     
  135.  #  It's quite an important procedure for completions, and must handle
  136.  #  pretty large lists, so it's worth optimising.
  137.  #     
  138.  #  Note '\\b' = word boundary, '\\s' = whitespace '\\S' = not-whitespace
  139.  # -------------------------------------------------------------------------
  140.  ##
  141. if {[info tclversion] < 8.0} {
  142.     proc completion::fromList { __cmd slist } {
  143.     global [lindex [split $slist "\("] 0]
  144.     # Find all matches as a list --- a v. clever trick if I say so myself
  145.     if {[regexp "(^|\\s)(${__cmd}\[^\\S\]*(\\s|\$))+" [set "$slist"] matches]} {
  146.         return [string trim $matches]
  147.     } else {
  148.         return ""
  149.     }
  150.     }
  151. } else {
  152.     proc completion::fromList { __cmd slist } {
  153.     global [lindex [split $slist "\("] 0]
  154.     set first [lsearch -glob [set $slist] "${__cmd}*"]
  155.     if {$first == -1} { return "" }
  156.     set first [lrange [set $slist] $first end]
  157.     regexp {^(.*)(.)$} $__cmd "" _find _last    
  158.     set _find "^[::quote::Regfind $_find]\[^$_last\].*"
  159.     set last [lsearch -regexp $first $_find]
  160.     if {$last == -1} {
  161.         incr last
  162.         while {[string match "${__cmd}*" [lindex $first $last]]} {
  163.         incr last
  164.         }
  165.     }
  166.     return [lrange $first 0 [incr last -1]]
  167.     }
  168. }
  169.  
  170. ## 
  171.  # -------------------------------------------------------------------------
  172.  #     
  173.  #    "completion::notAlready" --
  174.  #    
  175.  #  Call this to check if we should divert directly to a previously
  176.  #  registered completion procedure instead of starting from scratch. 
  177.  # -------------------------------------------------------------------------
  178.  ##
  179. proc completion::notAlready {} {
  180.     global completion::in_progress_proc completion::in_progress_pos
  181.     # do the old completion if possible
  182.     if {[pos::compare ${completion::in_progress_pos} == [getPos]] } {
  183.     return [catch {completion [modeALike] ${completion::in_progress_proc}} ]
  184.     } else {
  185.     return 1
  186.     }    
  187. }
  188.  
  189. ## 
  190.  # -------------------------------------------------------------------------
  191.  #     
  192.  #    "completion::already"    --
  193.  #    
  194.  #  If a completion routine has been called once, and would like to be
  195.  #  called again (to cycle through a number of possibilities), then it
  196.  #  should register itself with this procedure. 
  197.  # -------------------------------------------------------------------------
  198.  ##
  199. proc completion::already { proc } {
  200.     global completion::in_progress_proc completion::in_progress_pos
  201.     # store the given completion
  202.     set completion::in_progress_proc $proc
  203.     set completion::in_progress_pos [getPos]
  204. }
  205.  
  206. ## 
  207.  # -------------------------------------------------------------------------
  208.  #     
  209.  #    "modeALike"    --
  210.  #    
  211.  #  Some modes are really equivalent as far as commands etc.  go, so
  212.  #  we don't bother with duplication. 
  213.  # -------------------------------------------------------------------------
  214.  ##
  215. proc modeALike {{m ""}} {
  216.     if {$m == ""} {
  217.     global mode
  218.     set m $mode
  219.     }
  220.     switch -- $m {
  221.     "C++" { return "C" }
  222.     "Shel" { return "Tcl" }
  223.     }
  224.     return $m
  225. }
  226.  
  227.  
  228.  
  229. ## 
  230.  # -------------------------------------------------------------------------
  231.  #     
  232.  #    "completion" --
  233.  #    
  234.  #     Call a    completion, by trying in order:
  235.  #       1) error
  236.  #       2) 'Type' is    actually a generic completion routine
  237.  #       3) '${mode}::Completion::${Type}' is a mode-specific routine
  238.  #       4) 'completion::${type}' is a generic routine.
  239.  #       
  240.  #     We also check for expansion procedures of the forms:
  241.  #       1) 'expansions::${type}'
  242.  #       2) '${mode}::Expansion::${Type}', where Type begins with 'Ex'
  243.  #
  244.  # -------------------------------------------------------------------------
  245.  ##
  246. proc completion { mode Type {match ""} } {
  247.     if { $Type == "error" } { error "" }
  248.     if {[string match "completion::*" $Type] \
  249.       || [string match "expansions::*" $Type]} {
  250.     return [$Type "${match}"]
  251.     } elseif {[llength [info commands ${mode}::Completion::${Type}]]} {
  252.     return [${mode}::Completion::${Type} "${match}"]
  253.     } elseif {[llength [info commands ${mode}::Expansion::${Type}]]} {
  254.     return [${mode}::Expansion::${Type} "${match}"]
  255.     } else {
  256.     return [eval completion::[string tolower $Type] \"${match}\"]
  257.     }
  258. }
  259.  
  260. proc completion::word {dummy} {
  261.     return [completion::update completion::word]
  262. }
  263.  
  264. proc completion::update { proc {got ""} {looking ""} } {
  265.     if {[completion::general $got $looking]} {
  266.     completion::already $proc
  267.     return 1
  268.     } else {
  269.     completion::already error
  270.     return 0
  271.     }
  272. }    
  273.  
  274. proc completion::general { {got ""} {looking ""} } {
  275.     global __wc__len __wc__prevPos completion::in_progress_pos \
  276.       __wc__prevFound __wc__pat __wc__nextStart __wc__fwd \
  277.       completion::in_progress_proc wordBreak \
  278.       __wc_prevHits
  279.     
  280.     set pos [getPos]
  281.     # Cursor changed place?
  282.     if {[pos::compare $pos == ${completion::in_progress_pos}]} {
  283.     # it is an old search
  284.     set ret [completion::wc__newSearch $pos]
  285.     if { $ret == 1 } {
  286.         return 1
  287.     } elseif { $ret == -1 } {
  288.         select [pos::math $pos + [expr {[string length $looking] - \
  289.           [string length $__wc__prevFound] - [string length $got]}]] $pos
  290.         return 0
  291.     }
  292.     }
  293.     # Start new search for completion::Word
  294.     if { $got == "" } {    
  295.     # this is a normal completion
  296.     set one [completion::lastWord start]
  297.     
  298.     set __wc__len [string length $one]
  299.     set __wc__pat [quote::Regfind $one]
  300.     append __wc__pat $wordBreak
  301.     } else {
  302.     # here we complete 'got' with something beginning 'looking'
  303.     set start [pos::math $pos - [string length $got]]
  304.     set one $looking
  305.     set __wc__len [string length $one]
  306.     set __wc__pat [quote::Regfind $one]
  307.     
  308.          # we want to find anything else which continues a 'word'
  309.     append __wc__pat $wordBreak
  310.     }    
  311.     set start [pos::math $start - 1]
  312.     set __wc_prevHits {}
  313.     
  314.     if {![catch {search -s -f 0 -r 1 -i 0 -m 1 -- $__wc__pat $start} data]} {
  315.     set d00 [lindex $data 0]
  316.     set beg [pos::math $d00 + $__wc__len]
  317.     set end [lindex $data 1]
  318.     set __wc__prevFound [getText $d00 $end]
  319.     lappend __wc_prevHits $__wc__prevFound
  320.     set txt [getText $beg $end]
  321.     goto $pos
  322.     insertText $txt
  323.     message "Found above."
  324.     # Set a number of globals for possible next go-around
  325.     set completion::in_progress_pos [getPos]
  326.     set __wc__prevPos $pos
  327.     set __wc__nextStart [pos::math $d00 - $__wc__len]
  328.     set __wc__fwd 0
  329.     return 1
  330.     }
  331.     if {![catch {search -s -f 1 -r 1 -i 0 -m 1 -- $__wc__pat $pos} data]} {
  332.     set __wc__prevFound [getText [lindex $data 0] [lindex $data 1] ]
  333.     lappend __wc_prevHits $__wc__prevFound
  334.     set beg [pos::math [lindex $data 0] + $__wc__len]
  335.     set end [lindex $data 1]
  336.     set txt [getText $beg $end]
  337.     goto $pos
  338.     insertText $txt
  339.     message "Found below."
  340.     # Set a number of globals for possible next go-around
  341.     set completion::in_progress_pos [getPos]
  342.     set __wc__prevPos $pos
  343.     set __wc__nextStart $end
  344.     set __wc__fwd 1
  345.     return 1
  346.     }
  347.     goto $pos
  348.     return 0
  349. }
  350.  
  351. # returns '1' if it succeeded 
  352. # or -1 if failed completely
  353.  
  354. proc completion::wc__newSearch { pos } {
  355.     global __wc__len __wc__prevPos completion::in_progress_pos \
  356.       __wc__prevFound __wc__pat __wc__nextStart __wc__fwd \
  357.       __wc_prevHits 
  358.     
  359.     while 1 {    
  360.     if {$__wc__fwd} {
  361.         set fndMsg "Found below."
  362.     } else {
  363.         set fndMsg "Found above."
  364.     }
  365.     if {![catch {search -s -f $__wc__fwd -r 1 -i 0 -m 1 -- $__wc__pat $__wc__nextStart} data]} {
  366.         set d00 [lindex $data 0]
  367.         set beg [pos::math $d00 + $__wc__len]
  368.         set end [lindex $data 1]
  369.         set Hit [getText $d00 $end]
  370.         
  371.         #if (this Hit is not the same as the last one)
  372.         if {[lsearch -exact $__wc_prevHits $Hit] == -1} {
  373.         
  374.         #add the hit to the list of previous hits
  375.         lappend __wc_prevHits $Hit
  376.         set __wc__prevFound $Hit
  377.         
  378.         set txt [getText $beg $end]
  379.         deleteText $__wc__prevPos ${completion::in_progress_pos}
  380.         goto $__wc__prevPos
  381.         insertText $txt
  382.         message $fndMsg
  383.         # Set a number of globals for possible next go-around
  384.         set completion::in_progress_pos [getPos]
  385.         if {$__wc__fwd} {
  386.             # Search Forwards
  387.             set __wc__nextStart $end
  388.             # End of found word
  389.         } else {
  390.             # Search Backwards
  391.             set __wc__nextStart [pos::math $d00 - $__wc__len]
  392.             # Before start of found word
  393.             if {[pos::compare $__wc__nextStart <= [minPos]]} {
  394.             set __wc__fwd 1
  395.             set __wc__nextStart ${completion::in_progress_pos}
  396.             }
  397.         }
  398.         return 1
  399.         } else {
  400.         # Move start of search after finding string again
  401.         if {$__wc__fwd} {
  402.             # Searching Forwards
  403.             set __wc__nextStart $end
  404.             # End of found word
  405.         } else {
  406.             # Still Searching Backwards
  407.             set __wc__nextStart [pos::math $d00 - $__wc__len]
  408.             # Before start of found word
  409.             if {[pos::compare $__wc__nextStart <= [minPos]]} {
  410.             set __wc__fwd 1
  411.             set __wc__nextStart ${completion::in_progress_pos}
  412.             }
  413.         }
  414.         }
  415.         # End if hit is the same as a previous hit
  416.     } else {
  417.         # Search string not found
  418.         if {$__wc__fwd} {
  419.         # We were already looking forward, so the word is not in the file
  420.         message "Not found."
  421.         set completion::in_progress_pos -1.0
  422.         goto $pos
  423.         return -1
  424.         } else {
  425.         # start looking forward
  426.         set __wc__fwd 1
  427.         set __wc__nextStart ${completion::in_progress_pos}
  428.         }
  429.     }
  430.     
  431.     }
  432.     return 0
  433. }
  434.  
  435. ## 
  436.  # -------------------------------------------------------------------------
  437.  #     
  438.  #    "completion::lastWord"    --
  439.  #    
  440.  #  Return the last word, without moving the cursor.  If a variable
  441.  #  name is given, it is returned containing the position of the start
  442.  #  of the last word.
  443.  #     
  444.  #  Future extensions to this proc (in packages) may include further
  445.  #  optional arguments. 
  446.  # -------------------------------------------------------------------------
  447.  ##
  448. proc completion::lastWord {{st ""}} {
  449.     set pos [getPos]
  450.     backwardWord
  451.     if {$st != ""} {upvar $st beg}
  452.     set beg [getPos]
  453.     goto $pos
  454.     if {[pos::compare $beg < [lineStart $pos]] \
  455.       || [pos::compare $beg == $pos]} {error ""}
  456.     return [getText $beg $pos]
  457. }
  458.  
  459.  
  460. ## 
  461.  # -------------------------------------------------------------------------
  462.  # 
  463.  # "completion::lastTwoWords" --
  464.  # 
  465.  #  Get last two words: returns the previous word, and sets the given var
  466.  #  to the word before that.  Note that the 'word before that' actually
  467.  #  means all text from the start of that word up to the beginning of the
  468.  #  word which is returned.  i.e. 'prev' will normally end in some sort of
  469.  #  space/punctuation.
  470.  #     
  471.  #  Future extensions to this proc (in packages) may include further
  472.  #  optional arguments. 
  473.  # -------------------------------------------------------------------------
  474.  ##
  475. proc completion::lastTwoWords {prev} {
  476.     set pos [getPos]
  477.     backwardWord
  478.     set beg_rhw [getPos]
  479.     backwardWord
  480.     set beg_lhw [getPos]
  481.     goto $pos
  482.     upvar $prev lhw
  483.     if {[pos::compare $beg_lhw < [lineStart $pos]] \
  484.       || [pos::compare $beg_lhw == $beg_rhw] } { 
  485.     set lhw { } 
  486.     } else {
  487.     set lhw [getText $beg_lhw $beg_rhw]
  488.     }
  489.     return [getText $beg_rhw $pos]
  490. }
  491.  
  492. ## 
  493.  # -------------------------------------------------------------------------
  494.  #     
  495.  #    "completion::tabDeleteSelection" --
  496.  #    
  497.  #  If there is a selection, this procedure is called by completion
  498.  #  routines to ask the user if it should be deleted (or if the
  499.  #  appropriate flag is set, to delete automatically). 
  500.  # -------------------------------------------------------------------------
  501.  ##
  502. proc completion::tabDeleteSelection {} {
  503.     global completion::in_progress_proc askDeleteSelection elecStopMarker
  504.     if {([regexp "^\$|^$elecStopMarker" [getSelect]] || !$askDeleteSelection)} {
  505.     deleteText [getPos] [selEnd]
  506.     } else {
  507.     if {[dialog::yesno "Delete selection?"]} {
  508.         deleteText [getPos] [selEnd]
  509.         set completion::in_progress_proc error
  510.     } else {
  511.         return 0
  512.     }
  513.     }
  514.     return 1
  515. }
  516.  
  517.  
  518.  
  519. ## 
  520.  # -------------------------------------------------------------------------
  521.  #     
  522.  # "completion::file" --
  523.  #    
  524.  #  Look back, see if there's a file/dir name and try and extend it. 
  525.  #  Useful for Shel mode.  This improves on the one that comes with Alpha
  526.  #  by default, and is much simpler. 
  527.  # -------------------------------------------------------------------------
  528.  ##
  529. proc completion::filename { {dummy ""}} {
  530.     set pos [getPos]
  531.     set res [search -s -f 0 -i 0 -m 0 -r 1 -n -- "\[\"\{ \t\r\n\]" \
  532.       [pos::math $pos - 1]]
  533.     if {[string length $res]} {
  534.     set from [lindex $res 1]
  535.     if {[pos::compare $from < $pos]} {
  536.         set pre ""
  537.         set text [getText $from $pos]
  538.         if {[catch {glob "${text}*"} globbed]} {
  539.         if {[catch {glob ":${text}*"} globbed]} {
  540.             return 0
  541.         }
  542.         set pre ":"
  543.         }
  544.         completion::Find "$pre$text" $globbed
  545.         return 1
  546.     }
  547.     }
  548. }
  549.  
  550. ## 
  551.  # -------------------------------------------------------------------------
  552.  #     
  553.  #    "completion::Find" --
  554.  #    
  555.  #  Insert the completion of 'cmd' from the list 'matches', and return
  556.  #  the complete match if there was one.
  557.  #    
  558.  #  'cmd' is what we have, 'matches' is a list of things which can
  559.  #  complete it, and 'forcequery' says don't bother with partial
  560.  #  completions: if we can't finish the command off, present the user
  561.  #  with a list. 
  562.  # -------------------------------------------------------------------------
  563.  ##
  564. proc completion::Find { cmd matches {isdbllist 0} {forcequery 0} {addQuery ""} {addAction ""}} {
  565.     global listPickIfMultCmps __univ_NotBlocked listPickIfNonUniqueStuckCmp
  566.     
  567.     set cmdlen [string length $cmd]
  568.     set mquery [set match [lindex $matches 0]]
  569.     if {$isdbllist} { set match [lindex [lindex $match 0] 0]}
  570.     if { [set cmdnum [llength $matches]] == 1 || $match == $cmd } {
  571.     # It's unique or already a command, so insert it 
  572.     # and turn off cmd completion.
  573.     if {$cmdnum != 1 && $listPickIfNonUniqueStuckCmp \
  574.       && (![catch { set match [listpick -p "Pick a completion" -L $mquery $matches]}])} {
  575.         if {$isdbllist} { set match [lindex [lindex $match 0] 0]}                    
  576.     } else {
  577.         message "Text is now a maximal completion."
  578.         # so we move on
  579.     }
  580.     set maxcompletion [string range $match $cmdlen end]
  581.     insertText $maxcompletion
  582.     # so we move on
  583.     return $match
  584.     } else {
  585.     set item [lindex $matches [incr cmdnum -1]]
  586.     if {$isdbllist} { set item [lindex [lindex $item 0] 0] }
  587.     set p [string length [largestPrefix [list $match $item]]]
  588.     #set p $cmdlen
  589.     #while {[string index $match $p]==[string index $item $p]} {incr p}
  590.     if { $p == $cmdlen || $forcequery } {
  591.         beep
  592.         if {$listPickIfMultCmps || $forcequery} {
  593.         if {$addQuery != ""} {
  594.             lappend matches "————————————————————————" $addQuery
  595.         }
  596.         if {[catch { set match [listpick -p "Pick a completion" -L $mquery $matches]}] \
  597.           || $match == "————————————————————————" } {
  598.             message "Cancelled"
  599.             return 1
  600.         } else {
  601.             if {$match == $addQuery} {
  602.             $addAction
  603.             return 1
  604.             }
  605.             if {$isdbllist} { set match [lindex [lindex $match 0] 0]}                    
  606.             set maxcompletion [string range $match $cmdlen end]
  607.             insertText $maxcompletion
  608.             # so we move on
  609.             return $match
  610.         }
  611.         
  612.         } else {
  613.         message "Can't extend --- ${matches}"
  614.         set __univ_NotBlocked 0
  615.         }
  616.     } else { 
  617.         set maxcompletion [string range $match $cmdlen [incr p -1]]
  618.         insertText $maxcompletion
  619.         message "Matching: ${matches}"
  620.     }        
  621.     return ""
  622.     }
  623.     
  624. }
  625.  
  626.  
  627.